home *** CD-ROM | disk | FTP | other *** search
/ Aminet 2 / Aminet AMIGA CDROM (1994)(Walnut Creek)[Feb 1994][W.O. 44790-1].iso / Aminet / dev / lang / PCQ12src.lzh / Source / Statements.p < prev    next >
Text File  |  1991-03-25  |  15KB  |  653 lines
  1. External;
  2.  
  3. {
  4.     Statements.p (of PCQ Pascal)
  5.     Copyright (c) 1989 Patrick Quaid
  6.  
  7.     This module handles normal statements, including the
  8.     standard statements like if, while, case, etc.
  9. }
  10.  
  11. {$O-}
  12. {$I "Pascal.i"}
  13.  
  14.     Function Match(s : Symbols) : Boolean;
  15.         external;
  16.     Function Expression : TypePtr;
  17.         external;
  18.     Procedure Error(s : string);
  19.         external;
  20.     Function TypeCheck(t1, t2 : TypePtr): Boolean;
  21.         external;
  22.     Procedure SaveStack(t : TypePtr);
  23.         external;
  24.     Procedure SaveVal(v : IDPtr);
  25.         external;
  26.     Procedure ns;
  27.         external;
  28.     Procedure NextSymbol;
  29.         external;
  30.     Function GetLabel : Integer;
  31.         external;
  32.     Procedure Mismatch;
  33.         external;
  34.     Function LoadAddress : TypePtr;
  35.         external;
  36.     Procedure CallProc(ProcID : IDPtr);
  37.         external;
  38.     procedure StdProc(ID : IDPtr);
  39.         external;
  40.     Function EndOfFile : Boolean;
  41.         external;
  42.     Procedure ReadChar;
  43.         external;
  44.     Function FindID(s : string): IDPtr;
  45.         external;
  46.     Function IsVariable(i : IDPtr) : Boolean;
  47.         external;
  48.     Function ConExpr(var t : TypePtr) : integer;
  49.         external;
  50.     function BaseType(t : TypePtr) : TypePtr;
  51.         external;
  52.     Procedure PromoteType(var f : TypePtr; o : TypePtr; r : Short);
  53.         external;
  54.     Function NumberType(t : TypePtr): Boolean;
  55.         external;
  56.     Procedure PushLongD0;
  57.         external;
  58.     Procedure PushLongA0;
  59.         External;
  60.     Procedure PopStackSpace(amount : Integer);
  61.         External;
  62.     Function Selector(ID : IDPtr) : TypePtr;
  63.         external;
  64.     Function FindWithField(s : String) : IDPtr;
  65.         External;
  66.     Function CheckBreak : Boolean;
  67.         External;
  68.     Procedure Abort;
  69.         External;
  70.     Procedure Assignment;
  71.         External;
  72.     Procedure AddConstant(Amount : Integer; ToReg : Regs; Size : Byte);
  73.         External;
  74.     Function GetReference : ExprPtr;
  75.         External;
  76.     Function ExpressionTree : ExprPtr;
  77.         External;
  78.     Procedure EvalAddress(Expr : ExprPtr; ToReg : Regs);
  79.         External;
  80.     Procedure Evaluate(Expr : ExprPtr; ToReg : Regs);
  81.         External;
  82.     Function PromoteTypeA(Expr : ExprPtr; DestType : TypePtr) : ExprPtr;
  83.         External;
  84.     Procedure Optimize(Expr : ExprPtr);
  85.         External;
  86.     Function SimpleReference(Expr : ExprPtr) : Boolean;
  87.         External;
  88.     Procedure FreeAllRegisters;
  89.         External;
  90.     Procedure StoreValue(Expr, Dest : ExprPtr);
  91.         External;
  92.     Procedure MarkRegister(reg : Regs);
  93.         External;
  94.     Procedure Out_Operation0(op : OpCodes);
  95.         External;
  96.     Procedure Out_Operation1(op : OpCodes; Size : Byte;
  97.                     EA : EAModes; Reg : Regs);
  98.         External;
  99.     Procedure Out_Operation2(op : OpCodes; Size : Byte;
  100.                     SrcEA : EAModes; SrcReg : Regs;
  101.                     DestEA : EAModes; DestReg : Regs);
  102.         External;
  103.     Procedure Out_Extension(Ext : Integer);
  104.         External;
  105.     Procedure WriteSimpleDest(Expr : ExprPtr; op : OpCodes; Size : Byte;
  106.                     SrcEA : EAModes; SrcReg : Regs;
  107.                     SExt1, SExt2 : Integer);
  108.         External;
  109.     Procedure WriteSimpleSource(Expr : ExprPtr; op : OpCodes; Size : Byte;
  110.                     DestEA : EAModes; DestReg : Regs);
  111.         External;
  112.  
  113.  
  114.  
  115. Procedure Statement;
  116.     forward;
  117.  
  118. Procedure ReturnVal;
  119.  
  120. {
  121.     This is similar to the above, but the value is left in d0.
  122. }
  123.  
  124. var
  125.     ExprType    : TypePtr;
  126. begin
  127.     nextsymbol;
  128.     if not Match(becomes1) then
  129.     error("expecting :=");
  130.     ExprType := Expression();
  131.     if not TypeCheck(CurrFn^.VType, ExprType) then
  132.     Mismatch;
  133.     if NumberType(ExprType) then
  134.     PromoteType(ExprType, CurrFn^.VType, 0);
  135.     AddConstant(StackLoad, a7, 4);
  136.     Out_Operation0(op_RESTORE);
  137.     Out_Operation1(op_UNLK,3,ea_Register,a5);
  138.     Out_Operation0(op_RTS);
  139. end;
  140.  
  141. Procedure DoWhile;
  142.  
  143. {
  144.     Handles the while statement.
  145. }
  146.  
  147. var
  148.     LoopLabel,
  149.     ExitLabel    : Integer;
  150. begin
  151.     LoopLabel := GetLabel();
  152.     ExitLabel := GetLabel();
  153.     Out_Operation1(op_LABEL,3,ea_Label,a7);
  154.     Out_Extension(LoopLabel);
  155.     MathLoaded := False;
  156.     if not TypeCheck(Expression(), BoolType) then
  157.     error("Expecting boolean expression");
  158.  
  159.     Out_Operation1(op_TST,1,ea_Register,d0);
  160.     Out_Operation1(op_BEQ,3,ea_Label,a7);
  161.     Out_Extension(ExitLabel);
  162.  
  163.     if not Match(Do1) then
  164.     error("Missing DO");
  165.     Statement;
  166.  
  167.     Out_Operation1(op_BRA,3,ea_Label,a7);
  168.     Out_Extension(LoopLabel);
  169.  
  170.     Out_Operation1(op_LABEL,3,ea_Label,a7);
  171.     Out_Extension(ExitLabel);
  172. end;
  173.  
  174. Procedure DoRepeat;
  175.  
  176. {
  177.     Handles the repeat statement.
  178. }
  179.  
  180. var
  181.     RepLabel    : Integer;
  182. begin
  183.     RepLabel := GetLabel();
  184.     Out_Operation1(op_LABEL,3,ea_Label,a7);
  185.     Out_Extension(RepLabel);
  186.  
  187.     MathLoaded := False;
  188.     while not Match(until1) do begin
  189.     Statement;
  190.     ns;
  191.     end;
  192.     if not TypeCheck(Expression(), Booltype) then
  193.     error("Expecting a Boolean expression.");
  194.  
  195.     Out_Operation1(op_TST,1,ea_Register,d0);
  196.     Out_Operation1(op_BEQ,3,ea_Label,a7);
  197.     Out_Extension(RepLabel);
  198. end;
  199.  
  200. Procedure DoFor;
  201.  
  202. {
  203.     handles the for statement.
  204. }
  205.  
  206. var
  207.     increment    : Short;
  208.     Dest,
  209.     Expr,
  210.     IncExpr    : ExprPtr;
  211.     BoundType    : TypePtr;
  212.     NumberIndex : Boolean;
  213.     STag    : Byte;
  214.     InLabel,
  215.     LoopLabel,
  216.     DoneLabel    : Integer;
  217.     Simple    : Boolean;
  218. begin
  219.     LoopLabel := GetLabel;  { Inc or Dec the index, getting ready to check }
  220.     InLabel   := GetLabel;  { Check index against upper bound }
  221.     DoneLabel := GetLabel;  { Done with loop, move along }
  222.  
  223.     NextFreeExprNode := 0;
  224.     FreeAllRegisters;
  225.     Dest := GetReference;
  226.     if Dest^.EType^.Object <> ob_ordinal then
  227.     Error("Expecting an ordinal type")
  228.     else
  229.     Optimize(Dest);
  230.     if not Match(becomes1) then
  231.     Error("missing :=");
  232.  
  233.     Expr := ExpressionTree;
  234.     BoundType := Dest^.EType;
  235.     STag := BoundType^.Size;
  236.  
  237.     NumberIndex := TypeCheck(BoundType, IntType);
  238.     if TypeCheck(BoundType, Dest^.EType) then begin
  239.     if NumberIndex then
  240.         Expr := PromoteTypeA(Expr, Dest^.EType);
  241.     Optimize(Expr);
  242.     end else
  243.     Mismatch;
  244.  
  245.     if Match(to1) then
  246.     increment := 1
  247.     else if Match(downto1) then
  248.     increment := -1
  249.     else
  250.     error("Expecting TO or DOWNTO");
  251.  
  252.     FreeAllRegisters;
  253.     Simple := SimpleReference(Dest);
  254.     StoreValue(Expr, Dest);        { _must_ leave dest in A0 }
  255.     if not Simple then
  256.     PushLongA0;
  257.  
  258.     Out_Operation1(op_BRA,3,ea_Label,a7);
  259.     Out_Extension(InLabel);
  260.  
  261.     Out_Operation1(op_LABEL,3,ea_Label,a7);
  262.     Out_Extension(LoopLabel);
  263.  
  264.     if Simple then begin
  265.     if Increment > 0 then
  266.         WriteSimpleDest(Dest, op_ADDQ,STag,ea_Constant,a7,1,0)
  267.     else
  268.         WriteSimpleDest(Dest, op_SUBQ,STag,ea_Constant,a7,1,0);
  269.     end else begin
  270.     Out_Operation2(op_MOVE,4,ea_Indirect,a7,ea_Register,a0);
  271.     if Increment > 0 then
  272.         Out_Operation2(op_ADDQ,STag,ea_Constant,a7,ea_Indirect,a0)
  273.     else
  274.         Out_Operation2(op_SUBQ,STag,ea_Constant,a7,ea_Indirect,a0);
  275.     Out_Extension(1);
  276.     end;
  277.  
  278.     Out_Operation1(op_LABEL,3,ea_Label,a7);
  279.     Out_Extension(InLabel);
  280.  
  281.     Expr := ExpressionTree;
  282.     if TypeCheck(Expr^.EType, BoundType) then begin
  283.     if NumberIndex then
  284.         Expr := PromoteTypeA(Expr, IntType);
  285.     Optimize(Expr);
  286.     end else
  287.     Mismatch;
  288.  
  289.     FreeAllRegisters;
  290.     Evaluate(Expr, d0);
  291.  
  292.     if Simple then
  293.     WriteSimpleSource(Dest,op_CMP,STag,ea_Register,d0)
  294.     else
  295.     Out_Operation2(op_CMP,STag,ea_Indirect,a0,ea_Register,d0);
  296.  
  297.     if increment > 0 then
  298.     Out_Operation1(op_BLT,3,ea_Label,a7)
  299.     else
  300.     Out_Operation1(op_BGT,3,ea_Label,a7);
  301.     Out_Extension(DoneLabel);
  302.  
  303.     if not Match(do1) then
  304.     Error("Missing DO");
  305.  
  306.     MathLoaded := False;
  307.     Statement;
  308.  
  309.     Out_Operation1(op_BRA,3,ea_Label,a7);
  310.     Out_Extension(LoopLabel);
  311.  
  312.     Out_Operation1(op_LABEL,3,ea_Label,a7);
  313.     Out_Extension(DoneLabel);
  314.  
  315.     if not Simple then
  316.     PopStackSpace(4);
  317. end;
  318.  
  319.  
  320.  
  321. Procedure DoReturn;
  322.  
  323. {
  324.     This just takes care of return.
  325. }
  326.  
  327. begin
  328.     if CurrFn <> Nil then begin
  329.     if CurrFn^.Object = proc then begin
  330.         AddConstant(StackLoad, a7, 4);
  331.         Out_Operation0(op_RESTORE);
  332.         Out_Operation1(op_UNLK,3,ea_Register,a5);
  333.         Out_Operation0(op_RTS);
  334.     end else
  335.         error("return only allowed in procedures.");
  336.     end else
  337.     error("No return from the main procedure");
  338. end;
  339.  
  340. Procedure Compound;
  341.  
  342. {
  343.     This takes care of the begin...end syntax.
  344. }
  345.  
  346. begin
  347.     while not Match(end1) do begin
  348.     Statement;
  349.     if (CurrSym = Else1) or (CurrSym = Until1) then begin
  350.         Error("Expecting a statement");
  351.         NextSymbol;
  352.     end;
  353.     if CurrSym <> End1 then
  354.         ns;
  355.     end;
  356. end;
  357.  
  358. procedure DoIf;
  359.  
  360. {
  361.     This handles the if statement.  Eventually it should handle
  362. elsif.
  363. }
  364.  
  365. var
  366.     flab1, flab2    : integer;
  367. begin
  368.     flab1 := GetLabel();
  369.     if not TypeCheck(Expression(), BoolType) then
  370.     error("Expecting a Boolean type");
  371.     Out_Operation1(op_TST,1,ea_Register,d0);
  372.     Out_Operation1(op_BEQ,3,ea_Label,a7);
  373.     Out_Extension(FLab1);
  374.  
  375.     if not Match(then1) then
  376.     error("Missing THEN");
  377.     Statement;
  378.  
  379.     if Match(else1) then begin
  380.     flab2 := getlabel();
  381.     Out_Operation1(op_BRA,3,ea_Label,a7);
  382.     Out_Extension(FLab2);
  383.  
  384.     Out_Operation1(op_LABEL,3,ea_Label,a7);
  385.     Out_Extension(FLab1);
  386.  
  387.     MathLoaded := False;
  388.     Statement;
  389.  
  390.     Out_Operation1(op_LABEL,3,ea_LABEL,a7);
  391.     Out_Extension(FLab2);
  392.     end else begin
  393.     Out_Operation1(op_LABEL,3,ea_LABEL,a7);
  394.     Out_Extension(FLab1);
  395.     end;
  396.     MathLoaded := False;
  397. end;
  398.  
  399. procedure DoCase;
  400.  
  401.     procedure DoRange(first, second, lab, typesize : Integer);
  402.     var
  403.     otherlabel : Integer;
  404.     begin
  405.     otherlabel := GetLabel();
  406.     Out_Operation2(op_CMP,TypeSize,ea_Constant,a7,ea_Register,d0);
  407.     Out_Extension(First);
  408.  
  409.     Out_Operation1(op_BLT,3,ea_Label,a7);
  410.     Out_Extension(OtherLabel);
  411.  
  412.     Out_Operation2(op_CMP,TypeSize,ea_Constant,a7,ea_Register,d0);
  413.     Out_Extension(Second);
  414.  
  415.     Out_Operation1(op_BLE,3,ea_Label,a7);
  416.     Out_Extension(Lab);
  417.  
  418.     Out_Operation1(op_LABEL,3,ea_Label,a7);
  419.     Out_Extension(OtherLabel);
  420.     end;
  421.  
  422.     procedure DoSingle(number, lab, typesize : Integer);
  423.     begin
  424.     Out_Operation2(op_CMP,TypeSize,ea_Constant,a7,ea_Register,d0);
  425.     Out_Extension(Number);
  426.  
  427.     Out_Operation1(op_BEQ,3,ea_Label,a7);
  428.     Out_Extension(Lab);
  429.     end;
  430.  
  431.     Procedure DoCases(ctype : TypePtr; codelabel : Integer);
  432.     var
  433.     firstnumber, secondnumber : Integer;
  434.     contype : TypePtr;
  435.     Quit    : Boolean;
  436.     begin
  437.     Quit := False;
  438.     repeat
  439.         firstnumber := ConExpr(ConType);
  440.         if not TypeCheck(ConType, ctype) then begin
  441.         Mismatch;
  442.         return;
  443.         end;
  444.         if Match(dotdot1) then begin
  445.         secondnumber := conexpr(contype);
  446.         if not typecheck(ctype, contype) then begin
  447.             mismatch;
  448.             return;
  449.         end;
  450.         dorange(firstnumber, secondnumber, codelabel,ctype^.Size);
  451.         end else
  452.         dosingle(firstnumber, codelabel, ctype^.size);
  453.         if currsym <> colon1 then
  454.         if not match(comma1) then begin
  455.             error("Expecting : or ,");
  456.             return;
  457.         end;
  458.     until Match(Colon1);
  459.     end;
  460.  
  461. var
  462.     casetype : TypePtr;
  463.     outofcases, nextsetlabel, codelabel : Integer;
  464. begin
  465.     CaseType := Expression();
  466.     if CaseType^.Object <> ob_ordinal then
  467.     error("Expecting an ordinal type");
  468.     if not match(of1) then
  469.     error("Missing 'of'");
  470.     outofcases := GetLabel();
  471.     while (currsym <> end1) and (currsym <> else1) and (not endoffile()) do begin
  472.     NextSetLabel := GetLabel();
  473.     CodeLabel := GetLabel();
  474.     DoCases(CaseType, CodeLabel);
  475.  
  476.     Out_Operation1(op_BRA,3,ea_Label,a7);
  477.     Out_Extension(NextSetLabel);
  478.  
  479.     Out_Operation1(op_LABEL,3,ea_Label,a7);
  480.     Out_Extension(CodeLabel);
  481.  
  482.     MathLoaded := False;
  483.     Statement;
  484.     if (CurrSym <> Else1) and (CurrSym <> End1) then
  485.         ns;
  486.  
  487.     Out_Operation1(op_BRA,3,ea_Label,a7);
  488.     Out_Extension(OutOfCases);
  489.  
  490.     Out_Operation1(op_LABEL,3,ea_Label,a7);
  491.     Out_Extension(NextSetLabel);
  492.     end;
  493.     if Match(else1) then
  494.     if CurrSym <> end1 then begin
  495.         Statement;
  496.         ns;
  497.     end;
  498.     if not Match(end1) then
  499.     Error("Expecting 'end'");
  500.  
  501.     Out_Operation1(op_LABEL,3,ea_Label,a7);
  502.     Out_Extension(OutOfCases);
  503. end;
  504.  
  505. Procedure DoWith;
  506. var
  507.     TempRec,
  508.     FirstRec : WithRecPtr;
  509.     Stay    : Boolean;
  510. begin
  511.     FirstRec := Nil;
  512.     repeat
  513.     New(TempRec);
  514.     if FirstRec = Nil then
  515.         FirstRec := TempRec;
  516.     TempRec^.Previous := FirstWith;
  517.     TempRec^.RecType := LoadAddress;
  518.     FirstWith := TempRec;
  519.     if FirstWith^.RecType^.Object <> ob_record then
  520.         Error("Expecting a record type");
  521.     PushLongA0;
  522.     FirstWith^.Offset := StackLoad;
  523.     Stay := Match(Comma1);
  524.     until not Stay;
  525.     if not Match(Do1) then
  526.     Error("Missing DO");
  527.     Statement;
  528.     repeat
  529.     Stay := FirstWith <> FirstRec;
  530.     TempRec := FirstWith^.Previous;
  531.     Dispose(FirstWith);
  532.     FirstWith := TempRec;
  533.     PopStackSpace(4);
  534.     until not Stay;
  535. end;
  536.  
  537. Procedure DoGoto;
  538. var
  539.     ID : IDPtr;
  540. begin
  541.     if CurrSym = Ident1 then begin
  542.     ID := FindID(SymText);
  543.     if ID <> Nil then begin
  544.         if ID^.Object = lab then begin
  545.         if ID^.Level = CurrentBlock^.Level then begin
  546.             Out_Operation1(op_BRA,3,ea_Label,a7);
  547.             Out_Extension(ID^.Unique);
  548.             NextSymbol;
  549.         end else
  550.             Error("You cannot jump out of scopes");
  551.         end else
  552.         Error("Expecting a label");
  553.     end else
  554.         Error("Unknown ID");
  555.     end else
  556.     Error("Expecting a comment");
  557. end;
  558.  
  559. Procedure Statement;
  560.  
  561. {
  562.     This is the main routine for handling statements of all
  563. sorts.  It distributes the work as necessary.
  564. }
  565.  
  566. var
  567.     VarIndex    : IDPtr;
  568. begin
  569.     if EndOfFile() then
  570.     return;
  571.     VarIndex := Nil;
  572.     if CurrSym = Ident1 then begin { Handle label prefix }
  573.     VarIndex := FindWithField(SymText);
  574.     if VarIndex = Nil then
  575.         VarIndex := FindID(SymText);
  576.     if VarIndex <> Nil then begin
  577.         if VarIndex^.Object = lab then begin
  578.         Out_Operation1(op_LABEL,3,ea_Label,a7);
  579.         Out_Extension(VarIndex^.Unique);
  580.         NextSymbol;
  581.         if not Match(Colon1) then
  582.             Error("Missing colon");
  583.         VarIndex := Nil;
  584.         end;
  585.     end else
  586.         Error("Unknown ID");
  587.     end;
  588.     if CurrSym = Ident1 then begin
  589.     if VarIndex = Nil then begin { if not Nil, we found it above }
  590.         VarIndex := FindWithField(SymText);
  591.         if VarIndex = Nil then
  592.         VarIndex := FindID(symtext);
  593.     end;
  594.     if varindex = nil then begin
  595.         error("unknown ID");
  596.         while (currsym <> semicolon1) and
  597.           (currsym <> end1) and
  598.           (currentchar <> chr(10)) do
  599.         nextsymbol;
  600.     end else if IsVariable(VarIndex) then
  601.         assignment
  602.     else if VarIndex^.Object = proc then
  603.         callproc(varindex)
  604.     else if VarIndex^.Object = stanproc then
  605.         stdproc(varindex)
  606.     else if varindex = currfn then begin
  607.         if currfn^.Object = func then
  608.         returnval
  609.         else begin
  610.         Error("Expecting a variable or procedure.");
  611.         NextSymbol;
  612.         end;
  613.     end else begin
  614.         error("expecting a variable or procedure.");
  615.         while (currsym <> semicolon1) and
  616.           (currsym <> end1) and
  617.           (currentchar <> chr(10)) do
  618.         nextsymbol;
  619.         if currsym = semicolon1 then
  620.         nextsymbol;
  621.     end;
  622.     end else if match(begin1) then begin
  623.     Compound;
  624.     end else if match(if1) then begin
  625.     DoIf;
  626.     end else if match(while1) then begin
  627.     DoWhile;
  628.     end else if match(repeat1) then begin
  629.     DoRepeat;
  630.     end else if match(for1) then begin
  631.     DoFor;
  632.     end else if match(case1) then begin
  633.     DoCase;
  634.     end else if match(return1) then begin
  635.     DoReturn;
  636.     end else if Match(With1) then begin
  637.     DoWith;
  638.     end else if Match(Goto1) then begin
  639.     DoGoto;
  640.     end else if (CurrSym <> SemiColon1) and (CurrSym <> End1) and
  641.         (CurrSym <> Else1) and (CurrSym <> Until1) then begin
  642.     Error("Expecting a statement");
  643.     while (CurrSym <> SemiColon1) and
  644.           (CurrSym <> End1) and
  645.           (CurrSym <> Else1) and
  646.           (CurrSym <> Until1) and
  647.           (currentchar <> chr(10)) do
  648.         NextSymbol;
  649.     end else
  650.     if CheckBreak then
  651.         Abort;
  652. end;
  653.